home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / getopt-long.scm.z / getopt-long.scm
Text File  |  2002-07-08  |  26KB  |  663 lines
  1. ;;; Author: Russ McManus
  2. ;;; $Id: getopt-long.scm,v 1.2 1999/02/15 12:53:10 jimb Exp $
  3. ;;;
  4. ;;; Copyright (C) 1998 FSF
  5. ;;;
  6. ;;; This program is free software; you can redistribute it and/or modify
  7. ;;; it under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2 of the License, or
  9. ;;; (at your option) any later version.
  10. ;;; 
  11. ;;; This program is distributed in the hope that it will be useful,
  12. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15. ;;; 
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with this program; if not, write to the Free Software
  18. ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19. ;;; 
  20. ;;; This module implements some complex command line option parsing, in
  21. ;;; the spirit of the GNU C library function 'getopt_long'.  Both long
  22. ;;; and short options are supported.
  23. ;;; 
  24. ;;; The theory is that people should be able to constrain the set of
  25. ;;; options they want to process using a grammar, rather than some arbitrary
  26. ;;; structure.  The grammar makes the option descriptions easy to read.
  27. ;;; 
  28.  
  29. ;;; getopt-long is a function for parsing command-line arguments in a
  30. ;;; manner consistent with other GNU programs.
  31.  
  32. ;;; (getopt-long ARGS GRAMMAR)
  33. ;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
  34. ;;;
  35. ;;; ARGS should be a list of strings.  Its first element should be the
  36. ;;; name of the program; subsequent elements should be the arguments
  37. ;;; that were passed to the program on the command line.  The
  38. ;;; `program-arguments' procedure returns a list of this form.
  39. ;;;
  40. ;;; GRAMMAR is a list of the form:
  41. ;;; ((OPTION (PROPERTY VALUE) ...) ...)
  42. ;;;
  43. ;;; Each OPTION should be a symbol.  `getopt-long' will accept a
  44. ;;; command-line option named `--OPTION'.
  45. ;;; Each option can have the following (PROPERTY VALUE) pairs:
  46. ;;; 
  47. ;;;   (single-char CHAR) --- Accept `-CHAR' as a single-character
  48. ;;;        equivalent to `--OPTION'.  This is how to specify traditional
  49. ;;;        Unix-style flags.
  50. ;;;   (required? BOOL) --- If BOOL is true, the option is required.
  51. ;;;        getopt-long will raise an error if it is not found in ARGS.
  52. ;;;   (value BOOL) --- If BOOL is #t, the option accepts a value; if
  53. ;;;        it is #f, it does not; and if it is the symbol
  54. ;;;        `optional', the option may appear in ARGS with or
  55. ;;;        without a value. 
  56. ;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
  57. ;;;        specified `(value #t)' for this option), then getopt
  58. ;;;        will apply FUNC to the value, and throw an exception
  59. ;;;        if it returns #f.  FUNC should be a procedure which
  60. ;;;        accepts a string and returns a boolean value; you may
  61. ;;;        need to use quasiquotes to get it into GRAMMAR.
  62. ;;;
  63. ;;; The (PROPERTY VALUE) pairs may occur in any order, but each
  64. ;;; property may occur only once.  By default, options do not have
  65. ;;; single-character equivalents, are not required, and do not take
  66. ;;; values.
  67. ;;; 
  68. ;;; In ARGS, single-character options may be combined, in the usual
  69. ;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy").  If an option
  70. ;;; accepts values, then it must be the last option in the
  71. ;;; combination; the value is the next argument.  So, for example, using
  72. ;;; the following grammar:
  73. ;;;      ((apples    (single-char #\a))
  74. ;;;       (blimps    (single-char #\b) (value #t))
  75. ;;;       (catalexis (single-char #\c) (value #t)))
  76. ;;; the following argument lists would be acceptable:
  77. ;;;    ("-a" "-b" "bang" "-c" "couth")     ("bang" and "couth" are the values
  78. ;;;                                         for "blimps" and "catalexis")
  79. ;;;    ("-ab" "bang" "-c" "couth")         (same)
  80. ;;;    ("-ac" "couth" "-b" "bang")         (same)
  81. ;;;    ("-abc" "couth" "bang")             (an error, since `-b' is not the
  82. ;;;                                         last option in its combination)
  83. ;;;
  84. ;;; If an option's value is optional, then `getopt-long' decides
  85. ;;; whether it has a value by looking at what follows it in ARGS.  If
  86. ;;; the next element is a string, and it does not appear to be an
  87. ;;; option itself, then that string is the option's value.
  88. ;;;
  89. ;;; The value of a long option can appear as the next element in ARGS,
  90. ;;; or it can follow the option name, separated by an `=' character.
  91. ;;; Thus, using the same grammar as above, the following argument lists
  92. ;;; are equivalent:
  93. ;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
  94. ;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
  95. ;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
  96. ;;;
  97. ;;; If the option "--" appears in ARGS, argument parsing stops there;
  98. ;;; subsequent arguments are returned as ordinary arguments, even if
  99. ;;; they resemble options.  So, in the argument list:
  100. ;;;         ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
  101. ;;; `getopt-long' will recognize the `apples' option as having the
  102. ;;; value "Granny Smith", but it will not recognize the `blimp'
  103. ;;; option; it will return the strings "--blimp" and "Goodyear" as
  104. ;;; ordinary argument strings.
  105. ;;;
  106. ;;; The `getopt-long' function returns the parsed argument list as an
  107. ;;; assocation list, mapping option names --- the symbols from GRAMMAR
  108. ;;; --- onto their values, or #t if the option does not accept a value.
  109. ;;; Unused options do not appear in the alist.
  110. ;;;
  111. ;;; All arguments that are not the value of any option are returned
  112. ;;; as a list, associated with the empty list.
  113. ;;;
  114. ;;; `getopt-long' throws an exception if:
  115. ;;; - it finds an unrecognized option in ARGS
  116. ;;; - a required option is omitted
  117. ;;; - an option that requires an argument doesn't get one
  118. ;;; - an option that doesn't accept an argument does get one (this can
  119. ;;;   only happen using the long option `--opt=value' syntax)
  120. ;;; - an option predicate fails
  121. ;;;
  122. ;;; So, for example:
  123. ;;;
  124. ;;; (define grammar
  125. ;;;   `((lockfile-dir (required? #t)
  126. ;;;                   (value #t)
  127. ;;;                   (single-char #\k)
  128. ;;;                   (predicate ,file-is-directory?))
  129. ;;;     (verbose (required? #f)
  130. ;;;              (single-char #\v)
  131. ;;;              (value #f))
  132. ;;;     (x-includes (single-char #\x))
  133. ;;;     (rnet-server (single-char #\y) 
  134. ;;;                  (predicate ,string?))))
  135. ;;;
  136. ;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include" 
  137. ;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
  138. ;;;                grammar)
  139. ;;; => ((() "foo1" "-fred" "foo2" "foo3")
  140. ;;;     (rnet-server . "lamprod")
  141. ;;;     (x-includes . "/usr/include")
  142. ;;;     (lockfile-dir . "/tmp")
  143. ;;;     (verbose . #t))
  144.  
  145.  
  146. (define-module (ice-9 getopt-long)
  147.   :use-module (ice-9 common-list))
  148. ;;; end-header
  149.  
  150.  
  151. ;;; The code on this page was expanded by hand using the following code:
  152. ;;; (pretty-print                 
  153. ;;;  (macroexpand                 
  154. ;;;   '(define-record option-spec 
  155. ;;;      (name                    
  156. ;;;       value                   
  157. ;;;       value-required?         
  158. ;;;       single-char             
  159. ;;;       predicate-ls            
  160. ;;;       parse-ls))))            
  161. ;;;
  162. ;;; This avoids the need to load slib for records.
  163. (define slib:error error)
  164. (begin (define
  165.          option-spec->name
  166.          (lambda
  167.            (obj)
  168.            (if (option-spec? obj)
  169.                (vector-ref obj 1)
  170.                (slib:error
  171.                  (quote option-spec->name)
  172.                  ": bad record"
  173.                  obj))))
  174.        (define
  175.          option-spec->value
  176.          (lambda
  177.            (obj)
  178.            (if (option-spec? obj)
  179.                (vector-ref obj 2)
  180.                (slib:error
  181.                  (quote option-spec->value)
  182.                  ": bad record"
  183.                  obj))))
  184.        (define
  185.          option-spec->value-required?
  186.          (lambda
  187.            (obj)
  188.            (if (option-spec? obj)
  189.                (vector-ref obj 3)
  190.                (slib:error
  191.                  (quote option-spec->value-required?)
  192.                  ": bad record"
  193.                  obj))))
  194.        (define
  195.          option-spec->single-char
  196.          (lambda
  197.            (obj)
  198.            (if (option-spec? obj)
  199.                (vector-ref obj 4)
  200.                (slib:error
  201.                  (quote option-spec->single-char)
  202.                  ": bad record"
  203.                  obj))))
  204.        (define
  205.          option-spec->predicate-ls
  206.          (lambda
  207.            (obj)
  208.            (if (option-spec? obj)
  209.                (vector-ref obj 5)
  210.                (slib:error
  211.                  (quote option-spec->predicate-ls)
  212.                  ": bad record"
  213.                  obj))))
  214.        (define
  215.          option-spec->parse-ls
  216.          (lambda
  217.            (obj)
  218.            (if (option-spec? obj)
  219.                (vector-ref obj 6)
  220.                (slib:error
  221.                  (quote option-spec->parse-ls)
  222.                  ": bad record"
  223.                  obj))))
  224.        (define
  225.          set-option-spec-name!
  226.          (lambda
  227.            (obj val)
  228.            (if (option-spec? obj)
  229.                (vector-set! obj 1 val)
  230.                (slib:error
  231.                  (quote set-option-spec-name!)
  232.                  ": bad record"
  233.                  obj))))
  234.        (define
  235.          set-option-spec-value!
  236.          (lambda
  237.            (obj val)
  238.            (if (option-spec? obj)
  239.                (vector-set! obj 2 val)
  240.                (slib:error
  241.                  (quote set-option-spec-value!)
  242.                  ": bad record"
  243.                  obj))))
  244.        (define
  245.          set-option-spec-value-required?!
  246.          (lambda
  247.            (obj val)
  248.            (if (option-spec? obj)
  249.                (vector-set! obj 3 val)
  250.                (slib:error
  251.                  (quote set-option-spec-value-required?!)
  252.                  ": bad record"
  253.                  obj))))
  254.        (define
  255.          set-option-spec-single-char!
  256.          (lambda
  257.            (obj val)
  258.            (if (option-spec? obj)
  259.                (vector-set! obj 4 val)
  260.                (slib:error
  261.                  (quote set-option-spec-single-char!)
  262.                  ": bad record"
  263.                  obj))))
  264.        (define
  265.          set-option-spec-predicate-ls!
  266.          (lambda
  267.            (obj val)
  268.            (if (option-spec? obj)
  269.                (vector-set! obj 5 val)
  270.                (slib:error
  271.                  (quote set-option-spec-predicate-ls!)
  272.                  ": bad record"
  273.                  obj))))
  274.        (define
  275.          set-option-spec-parse-ls!
  276.          (lambda
  277.            (obj val)
  278.            (if (option-spec? obj)
  279.                (vector-set! obj 6 val)
  280.                (slib:error
  281.                  (quote set-option-spec-parse-ls!)
  282.                  ": bad record"
  283.                  obj))))
  284.        (define
  285.          option-spec?
  286.          (lambda
  287.            (obj)
  288.            (and (vector? obj)
  289.                 (= (vector-length obj) 7)
  290.                 (eq? (vector-ref obj 0) (quote option-spec)))))
  291.        (define
  292.          make-option-spec
  293.          (lambda
  294.            (option-spec->name
  295.              option-spec->value
  296.              option-spec->value-required?
  297.              option-spec->single-char
  298.              option-spec->predicate-ls
  299.              option-spec->parse-ls)
  300.            (vector
  301.              (quote option-spec)
  302.              option-spec->name
  303.              option-spec->value
  304.              option-spec->value-required?
  305.              option-spec->single-char
  306.              option-spec->predicate-ls
  307.              option-spec->parse-ls))))
  308.  
  309.  
  310. ;;;
  311. ;;; parse functions go on this page.
  312. ;;;
  313. (define make-user-predicate
  314.   (lambda (pred)
  315.     (lambda (spec)
  316.       (let ((val (option-spec->value spec)))
  317.     (if (and val
  318.          (pred val)) #t
  319.          (error "option predicate failed:" (option-spec->name spec)))))))
  320.  
  321. (define make-not-allowed-value-fn
  322.   (lambda ()
  323.     (lambda (spec)
  324.       (let ((val (option-spec->value spec)))
  325.     (if (not (or (eq? val #t)
  326.              (eq? val #f)))
  327.         (let ((name (option-spec->name spec)))
  328.           (error "option does not support argument:" name)))))))
  329.  
  330. (define make-option-required-predicate
  331.   (lambda ()
  332.     (lambda (spec)
  333.       (let ((val (option-spec->value spec)))
  334.     (if (not val)
  335.         (let ((name (option-spec->name spec)))
  336.           (error "option must be specified:" name)))))))
  337.  
  338. (define make-option-value-predicate 
  339.   (lambda (predicate)
  340.     (lambda (spec)
  341.       (let ((val (option-spec->value spec)))
  342.     (if (not (predicate val))
  343.         (let ((name (option-spec->name spec)))
  344.           (error "Bad option value:" name val)))))))
  345.  
  346. (define make-required-value-fn
  347.   (lambda ()
  348.     (lambda (spec)
  349.       (let ((val (option-spec->value spec)))
  350.     (if (eq? val #t)
  351.         (let ((name (option-spec->name spec)))
  352.           (error "option must be specified with argument:" name)))))))
  353.  
  354. (define single-char-value? 
  355.   (lambda (val)
  356.     (char? val)))
  357.  
  358. (define (parse-option-spec desc)
  359.   (letrec ((parse-iter
  360.         (lambda (spec)
  361.           (let ((parse-ls (option-spec->parse-ls spec)))
  362.         (if (null? parse-ls)
  363.             spec
  364.             (let ((ls (car parse-ls)))
  365.               (if (or (not (list? ls))
  366.                   (not (= (length ls) 2)))
  367.               (error "Bad option specification:" ls))
  368.               (let ((key (car ls))
  369.                 (val (cadr ls)))
  370.             (cond ((and (eq? key 'required?) val)
  371.                    ;; required values are implemented as a predicate
  372.                    (parse-iter (make-option-spec (option-spec->name spec)
  373.                                  (option-spec->value spec)
  374.                                  (option-spec->value-required? spec)
  375.                                  (option-spec->single-char spec)
  376.                                  (cons (make-option-required-predicate)
  377.                                    (option-spec->predicate-ls spec))
  378.                                  (cdr parse-ls))))
  379.                   ;; if the value is not required, then don't add a predicate,
  380.                   ((eq? key 'required?)
  381.                    (parse-iter (make-option-spec (option-spec->name spec)
  382.                                  (option-spec->value spec)
  383.                                  (option-spec->value-required? spec)
  384.                                  (option-spec->single-char spec)
  385.                                  (option-spec->predicate-ls spec)
  386.                                  (cdr parse-ls))))
  387.                   ;; handle value specification
  388.                   ((eq? key 'value)
  389.                    (cond ((eq? val #t)
  390.                       ;; when value is required, add a predicate to that effect
  391.                       ;; and record the fact in value-required? field.
  392.                       (parse-iter (make-option-spec (option-spec->name spec)
  393.                                     (option-spec->value spec)
  394.                                     #t
  395.                                     (option-spec->single-char spec)
  396.                                     (cons (make-required-value-fn) 
  397.                                       (option-spec->predicate-ls spec))
  398.                                     (cdr parse-ls))))
  399.                      ((eq? val #f)
  400.                       ;; when the value is not allowed, add a predicate to that effect.
  401.                       ;; one can detect that a value is not supplied by checking the option
  402.                       ;; value against #f.
  403.                       (parse-iter (make-option-spec (option-spec->name spec)
  404.                                     (option-spec->value spec)
  405.                                     #f
  406.                                     (option-spec->single-char spec)
  407.                                     (cons (make-not-allowed-value-fn) 
  408.                                       (option-spec->predicate-ls spec))
  409.                                     (cdr parse-ls))))
  410.                      ((eq? val 'optional)
  411.                       ;; for optional values, don't add a predicate.  do, however
  412.                       ;; put the value 'optional in the value-required? field.  this
  413.                       ;; setting checks whether optional values are 'greedy'.  set
  414.                       ;; to #f to make optional value clauses 'non-greedy'.
  415.  
  416.                       (parse-iter (make-option-spec (option-spec->name spec)
  417.                                     (option-spec->value spec)
  418.                                     'optional
  419.                                     (option-spec->single-char spec)
  420.                                     (option-spec->predicate-ls spec)
  421.                                     (cdr parse-ls))))
  422.                      (#t
  423.                       ;; error case
  424.                       (error "Bad value specification for option:" (cons key val)))))
  425.                   ;; specify which single char is defined for this option.
  426.                   ((eq? key 'single-char)
  427.                    (if (not (single-char-value? val))
  428.                    (error "Not a single-char-value:" val " for option:" key)
  429.                    (parse-iter (make-option-spec (option-spec->name spec)
  430.                                  (option-spec->value spec)
  431.                                  (option-spec->value-required? spec)
  432.                                  val
  433.                                  (option-spec->predicate-ls spec)
  434.                                  (cdr parse-ls)))))
  435.                   ((eq? key 'predicate)
  436.                    (if (procedure? val)
  437.                    (parse-iter (make-option-spec (option-spec->name spec)
  438.                                  (option-spec->value spec)
  439.                                  (option-spec->value-required? spec)
  440.                                  (option-spec->single-char spec)
  441.                                  (cons (make-user-predicate val)
  442.                                        (option-spec->predicate-ls spec))
  443.                                  (cdr parse-ls)))
  444.                    (error "Bad predicate specified for option:" (cons key val))))))))))))
  445.     (if (or (not (pair? desc))
  446.         (string? (car desc)))
  447.     (error "Bad option specification:" desc))
  448.     (parse-iter (make-option-spec (car desc)
  449.                   #f 
  450.                   #f
  451.                   #f
  452.                   '()
  453.                   (cdr desc)))))
  454.  
  455.  
  456. ;;;
  457. ;;; 
  458. ;;;
  459. (define (split-arg-list argument-list)
  460.   "Given an ARGUMENT-LIST, decide which part to process for options.  
  461. Everything before an arg of \"--\" is fair game, everything after it 
  462. should not be processed.  The \"--\" is discarded.  A cons pair is 
  463. returned whose car is the list to process for options, and whose cdr 
  464. is the list to not process."
  465.   (let loop ((process-ls '())
  466.          (not-process-ls argument-list))
  467.     (cond ((null? not-process-ls)
  468.        (cons (reverse process-ls) '()))
  469.       ((string=? "--" (car not-process-ls))
  470.        (cons (reverse process-ls) (cdr not-process-ls)))
  471.       (#t
  472.        (loop (cons (car not-process-ls) process-ls)
  473.          (cdr not-process-ls))))))
  474.  
  475. (define short-opt-rx (make-regexp "^-([a-zA-Z]+)"))
  476. (define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
  477. (define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
  478.  
  479. (define (single-char-expander specifications opt-ls)
  480.   "Expand single letter options that are mushed together."
  481.   (let ((response #f))
  482.     (define (is-short-opt? str)
  483.       (set! response (regexp-exec short-opt-rx str))
  484.       response)
  485.     (define (iter opt-ls ret-ls)
  486.       (cond ((null? opt-ls)
  487.          (reverse ret-ls))
  488.         ((is-short-opt? (car opt-ls))
  489.          (let* ((orig-str (car opt-ls))
  490.             (match-pair (vector-ref response 2))
  491.             (match-str (substring orig-str (car match-pair) (cdr match-pair))))
  492.            (if (= (string-length match-str) 1)
  493.            (iter (cdr opt-ls)
  494.              (cons (string-append "-" match-str) ret-ls))
  495.            (iter (cons (string-append "-" (substring match-str 1)) (cdr opt-ls))
  496.              (cons (string-append "-" (substring match-str 0 1)) ret-ls)))))
  497.         (#t (iter (cdr opt-ls)
  498.               (cons (car opt-ls) ret-ls)))))
  499.     (iter opt-ls '())))
  500.  
  501. (define (process-short-option specifications argument-ls alist)
  502.   "Process a single short option that appears at the front of the ARGUMENT-LS,
  503. according to SPECIFICATIONS.  Returns #f is there is no such argument.  Otherwise 
  504. returns a pair whose car is the list of remaining arguments, and whose cdr is a 
  505. new association list, constructed by adding a pair to the supplied ALIST.  
  506. The pair on the front of the returned association list describes the  option 
  507. found at the head of ARGUMENT-LS.  The way this routine currently works, an 
  508. option that never takes a value that is followed by a non option will cause 
  509. an error, which is probably a bug.  To fix the bug the option specification
  510. needs to record whether the option ever can take a value."
  511.   (define (short-option->char option)
  512.     (string-ref option 1))
  513.   (define (is-short-option? option)
  514.     (regexp-exec short-opt-rx option))
  515.   (define (is-long-option? option)
  516.     (or (regexp-exec long-opt-with-value-rx option)
  517.     (regexp-exec long-opt-no-value-rx option)))
  518.   (define (find-matching-spec option)
  519.     (let ((key (short-option->char option)))
  520.       (find-if (lambda (spec) (eq? key (option-spec->single-char spec))) specifications)))
  521.   (let ((option (car argument-ls)))
  522.     (if (is-short-option? option)
  523.     (let ((spec (find-matching-spec option)))
  524.       (if spec
  525.           (let* ((next-value (if (null? (cdr argument-ls)) #f (cadr argument-ls)))
  526.              (option-value (if (and next-value
  527.                         (not (is-short-option? next-value))
  528.                         (not (is-long-option? next-value))
  529.                         (option-spec->value-required? spec))
  530.                        next-value
  531.                        #t))
  532.              (new-alist (cons (cons (option-spec->name spec) option-value) alist)))
  533.         (cons (if (eq? option-value #t)
  534.               (cdr argument-ls)   ; there was one value specified, skip just one
  535.               (cddr argument-ls)) ; there must have been a value specified, skip two
  536.               new-alist))
  537.           (error "No such option:" option)))
  538.     #f)))
  539.  
  540. (define (process-long-option specifications argument-ls alist)
  541.   (define (find-matching-spec key)
  542.     (find-if (lambda (spec) (eq? key (option-spec->name spec))) specifications))
  543.   (define (split-long-option option)
  544.     ;; returns a pair whose car is a symbol naming the option, cdr is
  545.     ;; the option value.  as a special case, if the option value is
  546.     ;; #f, then the caller should use the next item in argument-ls as
  547.     ;; the option value.
  548.     (let ((resp (regexp-exec long-opt-no-value-rx option)))
  549.       (if resp
  550.       ;; Aha, we've found a long option without an equal sign.
  551.       ;; Maybe we need to grab a value from argument-ls.  To find
  552.       ;; out we need to refer to the option-spec.
  553.       (let* ((key-pair (vector-ref resp 2))
  554.          (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
  555.          (spec (find-matching-spec key)))
  556.         (cons key (if (option-spec->value-required? spec) #f #t)))
  557.       (let ((resp (regexp-exec long-opt-with-value-rx option)))
  558.         ;; Aha, we've found a long option with an equal sign.  The
  559.         ;; option value is simply the value to the right of the
  560.         ;; equal sign.
  561.         (if resp
  562.         (let* ((key-pair (vector-ref resp 2))
  563.                (key (string->symbol (substring option (car key-pair) (cdr key-pair))))
  564.                (value-pair (vector-ref resp 3))
  565.                (value (substring option (car value-pair) (cdr value-pair))))
  566.           (cons key value))
  567.           #f)))))
  568.   (let* ((option (car argument-ls))
  569.      (pair (split-long-option option)))
  570.     (cond ((and pair (eq? (cdr pair) #f))
  571.        (if (null? (cdr argument-ls))
  572.            (error "Not enough options.")
  573.            (cons (cddr argument-ls)
  574.              (cons (cons (car pair) (cadr argument-ls)) alist))))
  575.       (pair
  576.        (cons (cdr argument-ls) (cons pair alist)))
  577.       (else #f))))
  578.  
  579. (define (process-options specifications argument-ls)
  580.   (define (iter argument-ls alist rest-ls)
  581.     (if (null? argument-ls)
  582.     (cons alist (reverse rest-ls))
  583.     (let ((pair (process-short-option specifications argument-ls alist)))
  584.       (if pair
  585.           (let ((argument-ls (car pair))
  586.             (alist (cdr pair)))
  587.         (iter argument-ls alist rest-ls))
  588.           (let ((pair (process-long-option specifications argument-ls alist)))
  589.         (if pair
  590.             (let ((argument-ls (car pair))
  591.               (alist (cdr pair)))
  592.               (iter argument-ls alist rest-ls))
  593.             (iter (cdr argument-ls)
  594.               alist
  595.               (cons (car argument-ls) rest-ls))))))))
  596.   (iter argument-ls '() '()))
  597.  
  598. (define (getopt-long program-arguments option-desc-list)
  599.   "Process options, handling both long and short options, similar to
  600. the glibc function 'getopt_long'.  PROGRAM-ARGUMENTS should be a value
  601. similar to what (program-arguments) returns.  OPTION-DESC-LIST is a
  602. list of option descriptions.  Each option description must satisfy the
  603. following grammar:
  604.  
  605.     <option-spec>           :: (<name> . <attribute-ls>)
  606.     <attribute-ls>          :: (<attribute> . <attribute-ls>)
  607.                                | ()
  608.     <attribute>             :: <required-attribute>
  609.                                | <arg-required-attribute>
  610.                                | <single-char-attribute>
  611.                                | <predicate-attribute>
  612.                                | <value-attribute>
  613.     <required-attribute>    :: (required? <boolean>)
  614.     <single-char-attribute> :: (single-char <char>)
  615.     <value-attribute>       :: (value #t)
  616.                                (value #f)
  617.                                (value optional)
  618.     <predicate-attribute>   :: (predicate <1-ary-function>)
  619.  
  620.     The procedure returns an alist of option names and values.  Each
  621. option name is a symbol.  The option value will be '#t' if no value
  622. was specified.  There is a special item in the returned alist with a
  623. key of the empty list, (): the list of arguments that are not options
  624. or option values.
  625.     By default, options are not required, and option values are not 
  626. required.  By default, single character equivalents are not supported;
  627. if you want to allow the user to use single character options, you need
  628. to add a 'single-char' clause to the option description."
  629.   (let* ((specifications (map parse-option-spec option-desc-list))
  630.      (pair (split-arg-list (cdr program-arguments)))
  631.      (split-ls (single-char-expander specifications (car pair)))
  632.      (non-split-ls (cdr pair)))
  633.     (let* ((opt-pair (process-options specifications split-ls))
  634.        (alist (car opt-pair))
  635.        (rest-ls (append (cdr opt-pair) non-split-ls)))
  636.       ;; loop through the returned alist, and set the values into the specifications
  637.       (for-each (lambda (pair)
  638.           (let* ((key (car pair))
  639.              (val (cdr pair))
  640.              (spec (find-if (lambda (spec) (eq? key (option-spec->name spec)))
  641.                     specifications)))
  642.             (if spec (set-option-spec-value! spec val))))
  643.         alist)
  644.       ;; now fire all the predicates
  645.       (for-each (lambda (spec)
  646.           (let ((predicate-ls (option-spec->predicate-ls spec)))
  647.             (for-each (lambda (predicate)
  648.                 (predicate spec))
  649.                   predicate-ls)))
  650.         specifications)
  651.       (cons (cons '() rest-ls) alist))))
  652.  
  653. (define (option-ref options key default)
  654.   "Look for an option value in OPTIONS using KEY.  If no such value is
  655. found, return DEFAULT."
  656.   (let ((pair (assq key options)))
  657.     (if pair
  658.     (cdr pair)
  659.     default)))
  660.  
  661. (export option-ref)
  662. (export getopt-long)
  663.